Aminet 1

home *** CD-ROM | disk | FTP | other *** search

/ Aminet 1 / Aminet - June 1993 [Walnut Creek].iso / usenet / sources / volume90 / aplictns / dtc / part02 < prev next >

Wrap

Internet Message Format | 1990-03-14 | 24.5 KB

Path: xanth!cs.odu.edu!Amiga-Request From: Amiga-Request@cs.odu.edu (Amiga Sources/Binaries Moderator) Newsgroups: comp.sources.amiga Subject: v90i108: DTC - desktop calendar, Part02/06 Message-ID: <11787@xanth.cs.odu.edu> Date: 14 Mar 90 01:30:50 GMT Sender: tadguy@cs.odu.edu Reply-To: "Glenn Everhart: 215 354 7610 (8*747 7610)" <EVERHART@ARISIA.dnet.ge.com> Lines: 1027 Approved: tadguy@cs.odu.edu (Tad Guy) X-Mail-Submissions-To: Amiga@cs.odu.edu X-Post-Discussions-To: comp.sys.amiga Submitted-by: "Glenn Everhart: 215 354 7610 (8*747 7610)" <EVERHART@ARISIA.dnet.ge.com> Posting-number: Volume 90, Issue 108 Archive-name: applications/dtc/part02 #!/bin/sh # This is a shell archive. Remove anything before this line, then unpack # it by saving it into a file and typing "sh file". To overwrite existing # files, type "sh file -c". You can also feed this as standard input via # unshar, or by typing "sh <file", e.g.. If this archive is complete, you # will see the following message at the end: # "End of archive 2 (of 6)." # Contents: Dtc.For.ac # Wrapped by tadguy@xanth on Tue Mar 13 20:29:22 1990 PATH=/bin:/usr/bin:/usr/ucb ; export PATH if test -f 'Dtc.For.ac' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'Dtc.For.ac'\" else echo shar: Extracting \"'Dtc.For.ac'\" $21940 characters$ sed "s/^X//" >'Dtc.For.ac' <<'END_OF_FILE' X itx1 = it1 X itx2 = it2 X X End If X X call shrink (1, ifnb, lnb) X X if (ifnb .eq. 0) then X if (idisp .eq. idspp) then X call dtcidate(im,id,iye) XC set to today's date X else X go to 999 XC Not enough info for U or X X end if X else XC If the date was specified in command line then Xc set id, im and iye to the right values: Xc X 10 call dtcdatcvt(3) XC (line) X X if (first) then XC Note we decode into X im = idmo XC second set of values, X id = iddy XC then copy into first set X iye = ibigyr XC first (or only) time around X end if XC (unlike Schlitz, we can go around twice) X X if (idisp .ne. idspp) then XC other than purge Xc *** itx2 = 175 XC Set default for '*' or <null> X call dtctimcvt(itx1, itx2) X if (itx1 .eq. itx2) X 1 itx2 = itx2 + 1 XC Add (10 mins) to allow semi-open interval X if (first) then X it1 = itx1 X it2 = itx2 X if (idisp .eq. idspx) then X if (ln1 .eq. 0) go to 999 XC Error if nothing left X first = .false. X go to 10 XC Re-cycle code X end if XC Done unless X X end if X else XC P, guarantee no redisplay X ln1 = 0 XC Zap the line X end if XC Done parse for U, X X end if XC Done date/time parse X X ixhash = ihymd(iye, im, id) XC Calc hash for day of interest X Xc *** type 950, ixhash Xc *** 950 format(2z9.8) X X if (idisp .eq. idspp) X 1 then XC Set request date for RDAPPT X irqhash(1) = ixhash XC Delete before X else X irqhash(1) = 0 XC Look at everybody X end if X X irqhash(2) = Z'7FFFFFFF' XC 'Til the end of time X X firstflg = 0 XC Zero until file opened for write X X prveof = 0 X eofflg = -1 X X do while (prveof .ge. 0) X X call dtcrdappt(eofflg, 1) XC Look at control entries X X if (eofflg .gt. 0) X 1 then X eofflg = 0 XC Don't open it on return X go to 190 XC but re-write it as is X XC Test it now X else if (eofflg .eq. 0) X 1 then X Xc *** type 950, irchash X X iht = min0(max0(iht, 80), 173) XC Insure a kosher time value X X go to (110, 120, 130) idisp XC Dispatch on numeric value X go to 190 XC Bad call, re-write anyway? X X 120 if ((irchash .eq. ixhash) .and. X 1 ((iht .ge. it1) .and. (iht .lt. it2))) X 2 go to 100 XC Criteria for Unscheduling (deleting) X go to 190 XC Do re-write X X 130 if ((irchash .eq. ixhash) .and. X 1 ((iht .ge. it1) .and. (iht .lt. it2))) X 2 then X X iht = itx1 + (iht - it1) XC Get updated time X if (mod(iht, 10) .eq. 6) iht = iht + 4 XC go to next hour X X if (iht .gt. itx2) go to 100 XC Duration was shortened X X ihy = ibigyr XC Change dates X ihm = idmo X ihd = iddy X X end if XC Usually re-write Xc X 110 continue XC Purge, re-write X XC Can't open output till X 190 if (firstflg .eq. 0) X 1 then XC we have input XC X X close(3) Xc open(unit=3, file=FNc(1:fnsz), status='NEW', Xc 1 form='FORMATTED', Xc 1 err=999) X9991 continue X open(unit=3, file='DTC.TMP', status='NEW', X 1 form='FORMATTED', X 1 err=999) X iopn2=1 Xc flag we got DTC.TMP open... X firstflg = 1 XC Output now open X X end if X X write (3, 201,err=9991) ihy, ihm, ihd, iht, X 1 apptstr(1:min0(max0(iaptln, 1), iaptlim)) Xc *** 1 (appoin(k), k=1, min0(max0(iaptln, 1), iaptlim)) X 201 format(i4.4, 2i2.2, i3.3, x, a) XC New format, 19850806113 X X end if XC eofflg X X 100 prveof = eofflg XC Set loop condition X X end do XC while X XC Purged everything? X if (firstflg .eq. 0) X 1 then XC create empty file X X close(3) Xc open(unit=3, file=FNc(1:fnsz), status='NEW', Xc 1 form='FORMATTED', Xc 1 err=999) X open(unit=3, file='DTC.TMP', status='NEW', X 1 form='FORMATTED', X 1 err=999) X iopn2=1 X firstflg = 1 XC Output now open X X end if X X if(iopn2.le.0)goto 9403 Xc Amiga ... Xc rewind 1 and 2, then copy DTC.TMP into DTC.DAT (or wherever) Xc Rewind 1 X close(1) X close(4) X open(unit=4, file=FNc(1:fnsz), status='NEW', X 1 form='FORMATTED',err=999) Xc re-open unit 4 if we can, for write... Xc Rewind 3 X close(3) X open(unit=3, file='DTC.TMP', status='old', X 1 form='FORMATTED', X 1 err=999) X X9402 continue X Read (3,201,end=9401,err=9401) ihy,ihm,ihd,iht,apptstr Xc read temp file, write back new appt file X write (4, 201,err=9401) ihy, ihm, ihd, iht, apptstr Xc 201 format(i4.4, 2i2.2, i3.3, x, a) X goto 9402 X9401 continue X close(3,Status='delete') X close(4) X firstflg=0 X iopn2=0 X9403 continue X close(3) X close(2) X close(4) X close(1) XC Done with new files X X return X X 999 write (iterm, 990) XC Error on decode, write nastygram X 990 format($,'Syntax or file-open (write) error.', $) X ln1 = 0 XC Inhibit rescan Xc X end XC -h- dtcdatcvt.for Tue Jul 8 16:07:21 1986 Xc Date conversion function (part of DTC), derived from DATMUN, Xc except decodes the values directly into DEFDAT and shrinks LINE, Xc rather than schlep LINE back and forth to kingdom come. XC Modified 850422, CG, to restrict values of month/day/year XC modified 850325, 850726 & 850731, CG, to allow any of the following: Xc d{d}/m{m}/{y}y, d, dd, dmm, ddmm, dmmyy, ddmmyy, dmmyyyy, ddmmyyyy Xc for D or W functions Xc m{m}/{y}y, m, mm, myy, mmyy, mmyyyy, myyyy for M Xc y, yy, yyy, yyyy for Y XC plus dd-mon-yy, dd-mm-yy, dd-xii-yy formats XC function: Xc Convert a line starting with a date of form Xc mmddyy OR mm/dd/yy OR dd-mon-yy OR dd-romn-yy Xc to binary equivalents, and remove from line, copying binary values Xc to DEFDAT in common. XC Leaves whatever follows the date alone. Xc Added for DTC to not have to use such a crock date Xc format as the original; too hard to use otherwise. X X Subroutine dtcdatcvt (nf) XC (line,nf) Xc Xc implicit none Xc X Integer*4 nf XC Number of fields expected Xc X include comdtc.INC Xc X INTEGER*1 nb, l1, l2, l3, l4, lxx(4), work(icmln), tb6(6) XC, Xc XC lengths of months (30 days hath Sept ...) X Integer*4 lm(12) Xc XC Min chars to recognize month names X Integer*4 minln(12) X XC Decode month names, or European style w/ Roman months X character*4 rch,mab(12),rom(12) X X Integer*4 i, k, kkk, n, nn, ix, ixyr, ixmo, ixdy, nfd, X 1 ifnb, lnb, lcount X X logical longyr XC If year entered as 3 chars or more X X integer*2 iwk(42), lw1 X integer*1 iwkk(84),ln1 X Character*1 ln1c X Equivalence (work,iwkk) XC 2 chars at a time Xc X Integer*4 ll1 X X equivalence(line(1),ln1) X equivalence (ln1,lw1),(ll1,rch) X equivalence (rch, lxx), (work, iwk) X equivalence(line(1),ln1c) Xc X Integer*4 icvt10, icur X INTEGER*1 ich X include stmtfuncsp.for X include comdtcd.inc X X Data lm X 1 /31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31/ Xc XC Min chars to recognize month names X Data minln X 1 /2, 1, 3, 2, 3, 3, 3, 2, 1, 1, 1, 1/ X XC Decode month names, or European style w/ Roman months X Data X 1 mab / 'JANU', 'FEBR', 'MARC', 'APRI', 'MAY ', 'JUNE', X 2 'JULY', 'AUGU', 'SEPT', 'OCTO', 'NOVE', 'DECE'/, X 3 rom / 'I ', 'II ', 'III ', 'IV ', 'V ', 'VI ', X 4 'VII ', 'VIII', 'IX ', 'X ', 'XI ', 'XII '/ X X include stmtfunc.for X icvt10(icur, ich) = (icur * 10) + icvtbn1(ich) XC conversion function stage X Xc Begin code X X longyr = .false. XC set default of century calculation X Xc Initialize default values for omitted fields X X ixyr = ibigyr XC Copy current values X ixmo = idmo XC from common X ixdy = iddy X if (numeric(ln1)) then XC Dates must start with number X X work(1) = ln1 XC Copy first character X ix = icvtbn1(ln1) XC Compute value on the fly Xc X do (n = 2, (nf * 2) + 2) XC Allow [mm][dd][yyyy] Xc X l1 = line(n) XC Copy current character X XC Field separators: slash X if (l1 .eq. ichar('/')) X 1 go to 100 XC for mm/dd/yy form X XC .. dash X if (l1 .eq. ichar('-')) X 1 go to 200 XC for dd-mmm-yy form X X if ((l1 .eq. ichar(':')) .or. (l1 .eq.ichar('>'))) X 1 go to 999 XC hour-string first, return default values XC anything else: X if (.not. numeric(l1)) X 1 go to 300 XC mmddyy, minus some characters, fake whatever is required X X work(n) = l1 XC Don't recopy X ix = icvt10(ix, l1) XC continue conversion X X end do X X n = (nf * 2) + 3 XC Set shrink value if no delimiter X X go to 300 XC Go convert it X X else if ((ln1c .eq. '+') .or. (ln1c .eq. '-')) then X k = incmod XC Save current value X call dtcdatinc XC Convert incremental date X incmod = k XC Restore X else if (ln1c .eq. '=') then X kkk = 1 XC Place holder, strip only, date n/c X go to 950 X end if XC (don't want to reformat whole file) X X go to 999 XC All done here X Xc handle mm/dd or mm/dd/yy{yy} (for D, W, M or Y) Xc or mm/yy{yy} (for M or Y) X X 100 continue XC Here for '/' encountered in first scan loop X X k = n + 1 XC next character to look at X l1 = line(k) X if (.not. numeric(l1)) go to 300 XC nnnn/x ??? X X ixmo = ix XC First field is always month in "/" notation X X ix = icvtbn1(l1) XC Start 2nd conversion X X do (n = k + 1, 20) XC should be plenty X X l1 = line(n) XC get character X if (l1 .eq. ichar('/')) go to 110 XC Found second / X if (.not. numeric(l1)) go to 120 XC End of scan X ix = icvt10(ix, l1) XC convert X X end do X X n = 21 XC Set it X X 120 if (nf .eq. 3) then X ixdy = ix XC 2nd field is day X else X ixyr = ix XC .. year X longyr = ((n - k) .gt. 2) X end if X X go to 900 X X 110 l1 = line(n+1) XC Found 2nd slash, check for third field X if (.not. numeric(l1)) go to 120 XC left field XC X X k = n + 1 X X ixdy = ix XC 2nd has to be day X X ixyr = icvtbn1(l1) XC Start 3rd conversion (year) X X do (n = k + 1, 20) XC get more numerics X X l1 = line(n) X if (.not. numeric(l1)) go to 910 X ixyr = icvt10(ixyr, l1) X X end do X X n = 21 XC mark next character X X go to 910 XC set for SHRINK X Xc handle dd-mon-yy, dd-mm-yy, or dd-roman-yy X X 200 continue XC Here for '-' in first scan loop X X ixdy = ix XC Copy converted day field X X rch = ' ' XC initialize for alpha month name, or Roman numerals X X k = n + 1 XC next char after "-" X X l1 = line(k) X X if (numeric(l1)) then XC European format dd-mm-yy X X ixmo = icvtbn1(l1) XC go for it directly X X do (n = k + 1, 20) X X l1 = line(n) X X if (.not. numeric(l1)) go to 210 X X ixmo = icvt10(ixmo, l1) X X end do X X n = 21 X X else if (alpha(l1)) then X X lxx(1) = l1 .and. z'5F5f5f5f' XC Set first char for name or roman X X lcount = 1 X X do (nn = k + 1, k + 6) XC should find "-" by then X X l1 = line(nn) X if (l1 .eq. ichar('-')) go to 230 XC Start search X if (.not. alpha(l1)) go to 230 XC also terminate X if (lcount .lt. 4) then XC room for at least one more X lcount = lcount + 1 X lxx(lcount) = l1 .and. z'5F5f5f5f' XC Copy character X end if X end do X X nn = k + 6 X X 230 continue X X do (i = 1, 12) XC Loop over months X if (rch .eq. rom(i)) go to 250 XC Found match in roman set X if (lcount .ge. minln(i)) then X if (rch(1:lcount) .eq. mab(i)(1:lcount)) X 1 go to 250 XC Found match in alpha names X end if X XC Note: last two IF statements above replace original horrendous sequence of Xc IF-THEN-ELSEs to see if month was J then A, or F, or M then A then R, etc XC X end do X Xc Fell out of loop, leave current month X X go to 300 XC Unknown month or roman seq, back up before "-" X X 250 ixmo = i XC iwk(1) = icvtbcd(i) X n = nn XC Accept characters X X else XC "-" followed by non alphanumeric X go to 300 X end if X X 210 if (l1 .ne. ichar('-')) go to 900 XC See if year follows X X k = n + 1 X l1 = line (k) X X if (.not. numeric(l1)) go to 910 XC First dash is left X ixyr = icvtbn1(l1) X X do (n = k + 1, 30) X X l1 = line (n) X X if (.not. numeric(l1)) go to 910 X X ixyr = icvt10(ixyr, l1) X X end do X X n = 31 X X 910 longyr = ((n - k) .gt. 2) XC Set logic value X X go to 900 X X300 continue XC Short string found, fix it up X X nfd = n/2 XC Number of 2-char groups found X X longyr = (nfd .gt. nf) XC check for default or forced century X X if ((n .and. 1) .eq. 0) then XC Example: n = 5 for 4 chars found (0 mod 2) X work(1) = '0' XC Force even number of characters X do (i = 2, n) X work(i) = line(i - 1) XC Shift line over by 1 X end do X end if X X go to (310, 320, 330) nf XC Dispatch on # expected fields X go to 900 XC Bad value ??? X X 310 ixyr = ix XC take year: Y [yy] X go to 900 XC End case X X 320 ixmo = icvtbin(iwkk(1)) XC M mm X if (nfd .eq. 2) ixyr = icvtbin(iwkk(3)) XC M {m}myy X if (nfd .eq. 3) ixyr = mod(ix, 10000) XC M {m}myyyy X go to 900 XC End case X X 330 if (nfd .eq. 1) ixdy = icvtbin(iwkk(1)) XC D {d}d {only} X X if (nfd .ge. 2) then XC D [mm]dd[yy] X ixmo = icvtbin(iwkk(1)) XC D {m}mdd X ixdy = icvtbin(iwkk(3)) XC D {m}mdd X end if X X if (nfd .eq. 3) ixyr = icvtbin(iwkk(5)) XC D {m}mddyy X if (nfd .eq. 4) ixyr = mod(ix, 10000) XC D {m}mddyyyy X X 900 continue XC common clean-up & return X XC Check for 1-99 AD X if ((ixyr .lt. 100) .and. (.not. longyr)) X 1 ixyr = ixyr + ((ibigyr/100)*100) XC add "current" century X X if (islpyr(ixyr)) X 1 then X lm(2) = 29 XC Set for Leap Years X else X lm(2) = 28 XC reset for "common" years X end if X X ibigyr = ixyr XC Explicit year X idmo = min0(max0(ixmo, 1), 12) XC Limit values X iddy = min0(max0(ixdy, 1), lm(idmo)) XC .. X X kkk = n - 1 XC Change index of next char to count X X 950 idyr = mod(ibigyr, 100) XC Set value X X if (kkk .gt. 0) X 1 call shrink (kkk, ifnb, lnb) XC Unload the stuff we used X X 999 return XC Miscellaneous exits X end Xc -h- dtctimcvt.for Tue Jul 8 16:08:13 1986 Xc Subroutine to extract and convert time-of-day string for DTC package Xc Converts string of form hh:mm to Integer*4 between 80 and 173 Xc (half-hour intervals). If range h1:m1>h2:m2 is present, second Xc value is returned, else same as t1>t1. X Xc Special cases Xc * => {itr1}>{itr2} Xc E or EV => 17:00 Xc h: => 0h:00 Xc h:n => 0h:n0 (if n .ge. 3, then 3, else 0) Xc h1>h2 => h1:00>h2:00 X Xc If ':' or '>' is not 2nd or 3rd character, or not '*', 'E' or 'EV', Xc entire string is left untouched, and default values are returned Xc (parameters unchanged) X X subroutine dtctimcvt (itr1, itr2) X X include comdtc.INC X X INTEGER*1 ll, ln1, wk(2) X integer*2 iwk X character*2 icwk X equivalence(icwk,iwk) X integer*1 iwkk X logical first, expectmin X X equivalence (line(1), ln1), (iwk, wk) X equivalence(iwkk,wk(1)) X include stmtfuncsp.for X include comdtcd.inc X include stmtfunc.for X X it1 = itr1 XC Caller's limits X it2 = itr2 XC (formerly 8:00 AM > 5:30 PM) X X ix = 0 XC Amount to strip X if(ln1.gt.96)ln1=ln1-32 X if (ln1 .eq. ichar('*')) then XC Check special cases first X X ix = 1 XC Defaults, dump 1 char X X else if ((ln1 ) .eq. ichar('E')) then X X it1 = 170 XC Set eventide X it2 = it1 X X ix = 1 X if(line(2).gt.96)line(2)=line(2)-32 X if ((line(2)) .eq. ichar('V')) ix = 2 X X else X X i = 0 XC Temp index X first = .true. XC Helpful X X 10 if (numeric(line(i+1))) then X X if (numeric(line(i+2))) then X wk(1) = line(i+1) X wk(2) = line(i+2) X read(icwk,850)ih X850 format(BZ ,I2) X ih=ih*10 Xc ih = icvtbin(iwkk) * 10 X i = i + 2 X else X ih = icvtbn1(line(i+1)) * 10 X i = i + 1 X end if X X if (line(i+1) .eq. ichar(':')) then X i = i + 1 X if (numeric(line(i+1))) then X im = icvtbn1(line(i+1)) X if (im .ge. 3) then X im = 3 X else X im = 0 X end if X ih = ih + im X i = i + 1 X if (numeric(line(i+1))) i = i + 1 XC Just ignore it X end if X ix = i XC Accept all processed chars X end if X X if ((ih .ge. 10) .and. (ih .lt. 70)) X 1 ih = ih + 120 XC Force early AM to PM X ih = min0(max0(ih, 80), 180) XC Normalize within limits X X if (line(i+1) .eq. ichar('>')) then X i = i + 1 X ix = i XC Insure it gets copied X it2 = ih X if (first) then X it1 = it2 X first = .false. X go to 10 X end if X else if (ix .ne. 0) then XC Got some numeric X if (first) then X it1 = ih XC terminated by ':' X it2 = ih XC first time t1>t1 X else X it2 = ih XC 2nd numeric X ix = i XC Claim everything looked at X end if XC Which time X end if XC Range delimiter ('>') X end if XC First numeric X end if XC All others unrecognized (includes EOL) X X itr1 = it1 XC All exit here X itr2 = max0(it2, it1) XC Make sure range OK X X if (ix .ne. 0) call shrink (ix, ifnb, lnb) XC Unload what we've used X X end XC -h- shrink.for Tue Jul 8 16:08:41 1986 Xc Subroutine to shift LINE to left after current item has been scanned Xc deletes blanks between that point and first non-blank character Xc Performs no operation if current item is EOL (binary 0) X Xc Sets return arguments pointing to first and last non-blank characters X X subroutine shrink (iskip, ifnbr, lnbr) Xc X include comdtc.INC X X INTEGER*1 ll X include comdtcd.inc X X ifnb = 0 X lnb = 0 X X if (line(1) .eq. 0) go to 999 XC Exit immediately X X ix = iskip + 1 XC start looking X do while ((ix .le. icmln) .and. (line(ix) .ne. 0)) X if (line(ix) .gt. 32) go to 10 XC Found something X ix = ix + 1 X end do X line(1) = 0 XC Flag end, no copy X go to 999 X X 10 ifnb = 1 X lnb = 1 X X Do (i = 1, icmln-ix) X X ll = line(ix) X line(i) = ll X if (ll .eq. 0) go to 999 XC Stop at EOL X if (ll .gt. 32) lnb = i X ix = ix + 1 X end do X line(min0(lnb+1, icmln)) = 0 XC Flag EOL if not found X X 999 ifnbr = ifnb XC Set return values X lnbr = lnb X X end XC -h- dtcat.for Tue Jul 8 16:09:05 1986 X subroutine dtcat(ic,ir) XC x, y Xc X include comdtc.INC XC Need ITERM X include escdtc.INC XC X include comdtcd.inc X include escdtcd.inc X write(iterm,773) X773 format(' ') Xc write once to flush extra junk out... then position. X write(iterm, 2, err=3) esc,'[',ir,';',ic,'H' X 2 format($,2a1,i2.2,a1,i3.3,a1,$) XC Max rows is 2-digit number Xc X return Xc X 3 write (iterm,10) esc,homescrn, ir, ic X 10 format($, 2a, 'Error in DTCAT, row/col =', 2z5.4, ' (hex).') X end XC -h- gaby.for Tue Jul 8 16:10:23 1986 Xc----------------------------------------------------------------------- XC Subroutine Gaby XC Part of Mitch Wyle's DTC program XC return a string corresponding to the month number Xc Month number contained in im. Send back string in monthn. Xc (JANUARY for 1, etc.) XC----------------------------------------------------------------------- XC modified 850315 - Center month names in table, use mixed case - CG X X SUBROUTINE gaby(im,monthn) X XC Declarations: Xc X INTEGER*1 monthn(9) XC Table of month names and numbers (centered, even lengths biased left): Xc X X INTEGER*1 months(9,14) X character*9 monthch(14) X X equivalence (months, monthch) XC Select the right month and fill monthn with it: Xc X Data monthch/ 'December ', X 1 ' January ', 'February ', ' March ', ' April ', X 2 ' May ', ' June ', ' July ', ' August ', X 3 'September', ' October ', 'November ', 'December ', X 4 ' January '/ X X XC ALLOW FOR OVERFLOWS... X IMM=IM+1 Xc *** monthn = monthch(imm) XC String assignment Xc X Do 1 i=1,9 XC INTEGER*1-at-a-time X Monthn(i) = months(i,imm) X 1 Continue X Xc All done. X X return X end Xc -h- ICVT routines X Integer*2 function Icvtbin(ich2) X Character*2 ich2 X Character*2 wrk X integer*2 iwrk,ians X Equivalence(wrk,iwrk) Xc convert 2 digit Integer*4 to number Xc avoid trick version from VAX that depends on byte Xc ordering (which fails on MC68000). X wrk=ich2 X Read(wrk,1,err=2)ians X1 Format(BN,I2) X2 Continue X Icvtbin=ians X Return X End X Function Icvtbn1(nnn) X Integer*1 nnn X Integer*4 kkk X kkk=48 X if(nnn.ge.48.and.nnn.le.57)kkk=nnn X kkk=kkk-48 Xc return 0 or digit value... X Icvtbn1=kkk X Return X End Xd subroutine dely Xd Integer*4 idly,i1 Xd common/xxxyyy/idly Xd idly=0 Xd do 1 i1=1,15000 Xd idly=idly+i1 Xd1 continue Xd idly=idly/100 Xd return Xd end X X END_OF_FILE if test 21940 -ne `wc -c <'Dtc.For.ac'`; then echo shar: \"'Dtc.For.ac'\" unpacked with wrong size! fi # end of 'Dtc.For.ac' fi echo shar: End of archive 2 $of 6$. cp /dev/null ark2isdone MISSING="" for I in 1 2 3 4 5 6 ; do if test ! -f ark${I}isdone ; then MISSING="${MISSING} ${I}" fi done if test "${MISSING}" = "" ; then echo You have unpacked all 6 archives. rm -f ark[1-9]isdone else echo You still need to unpack the following archives: echo " " ${MISSING} fi ## End of shell archive. exit 0 -- Mail submissions (sources or binaries) to <amiga@cs.odu.edu>. Mail comments to the moderator at <amiga-request@cs.odu.edu>. Post requests for sources, and general discussion to comp.sys.amiga.